home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / display-imag.lisp < prev    next >
Text File  |  1990-07-31  |  18KB  |  427 lines
  1. ;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp;  -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package "CLIO-OPEN")
  23.  
  24. (export '(
  25.       make-display-image
  26.       display-image
  27.       display-image-source
  28.       )
  29.     'clio-open)
  30.  
  31.  
  32. ;;;----------------------------------------------------------------------------+
  33. ;;;                                                                            |
  34. ;;;                               DISPLAY IMAGE                                |
  35. ;;;                                                                            |
  36. ;;;----------------------------------------------------------------------------+
  37.  
  38. (defcontact display-image (gravity-mixin core contact)
  39.   ;; Source is what is given and/or returned by/to outside callers.
  40.   ;; Internally, source is converted to source-pixmap for all other operations.
  41.   ((source         :type        (or null pixmap image)
  42.              :initform    nil
  43.              :initarg    :source
  44.              :reader    display-image-source     ;; SETF method defined below
  45.              )
  46.    (source-pixmap     :type        (or null pixmap)    ;; internal storage
  47.              :initform    nil)
  48.    (source-pixmap-width  :type        card16            ;; internal storage
  49.              :initform    0)
  50.    (source-pixmap-height :type        card16            ;; internal storage
  51.              :initform    0)     
  52.  
  53.    (compress-exposures   :initform       :off
  54.               :type           (member :off :on)
  55.              :reader         contact-compress-exposures
  56.              :allocation     :class))
  57.   
  58.   (:resources source))
  59.  
  60.  
  61. (defmethod (setf display-gravity) (new-gravity (display-image display-image))
  62.   (check-type new-gravity (or gravity (member :tiled)))
  63.   (setf (slot-value display-image 'gravity) new-gravity))
  64.  
  65.   
  66. (defmethod (setf display-image-source) ((new-source pixmap) (display-image display-image))
  67.   (with-slots (source source-pixmap source-pixmap-width source-pixmap-height depth) display-image
  68.     (with-state (new-source)
  69.       (let ((source-depth (drawable-depth new-source)))
  70.     (assert (or (= source-depth depth) (= source-depth 1)) ()
  71.         "~a depth is ~a, which is neither 1 nor ~a." new-source source-depth depth)
  72.     
  73.     (setf source-pixmap-width  (drawable-width new-source)
  74.           source-pixmap-height (drawable-height new-source)
  75.           source-pixmap        (when (realized-p display-image)
  76.                      (realize-display-image display-image new-source)))
  77.     
  78.     (setf source new-source)))))
  79.  
  80. (defmethod (setf display-image-source) ((new-source image) (display-image display-image))
  81.   (with-slots (source source-pixmap source-pixmap-width source-pixmap-height foreground depth) display-image
  82.     (let ((source-depth (image-depth new-source)))
  83.       (assert (or (= source-depth depth) (= source-depth 1)) ()
  84.           "~a depth is ~a, which is neither 1 nor ~a." new-source source-depth depth)
  85.       
  86.       (setf source-pixmap-width  (image-width new-source)
  87.         source-pixmap-height (image-height new-source)
  88.         source-pixmap        (when (realized-p display-image)
  89.                      (realize-display-image display-image new-source)))
  90.       
  91.       (setf source new-source))))
  92.  
  93. (defmethod (setf display-image-source) (new-source (display-image display-image))
  94.   (assert (not new-source) () "New source is ~a, which is not NIL, a PIXMAP, or an IMAGE.")
  95.   (with-slots (source source-pixmap source-pixmap-width source-pixmap-height) display-image
  96.     (setf source-pixmap-width  0
  97.       source-pixmap-height 0
  98.       source-pixmap        nil) 
  99.     
  100.     (setf source new-source)))
  101.  
  102. (defmethod (setf display-image-source) :after (new-source (display-image display-image))
  103.   (declare (ignore new-source))
  104.   (when (realized-p display-image)
  105.     (clear-area display-image)
  106.     (display display-image)))
  107.  
  108. (defmethod realize-display-image ((display-image display-image) (new-source pixmap))
  109.   (with-slots (source-pixmap-width source-pixmap-height foreground depth) display-image
  110.     (if (= (drawable-depth new-source) depth)
  111.     new-source
  112.     
  113.     ;; Else expand bitmap to full depth pixmap.
  114.     (let ((pixmap (create-pixmap
  115.             :drawable display-image
  116.             :width    source-pixmap-width
  117.             :height   source-pixmap-height
  118.             :depth    depth)))
  119.       (using-gcontext
  120.         (gc :drawable   display-image
  121.         :foreground foreground
  122.         :background (contact-current-background-pixel display-image))
  123.         (copy-plane new-source gc 1        ; Note, this is a mask, not an index.
  124.             0 0 source-pixmap-width source-pixmap-height
  125.             pixmap 0 0))
  126.       pixmap))))
  127.  
  128. (defmethod realize-display-image ((display-image display-image) (new-source image))
  129.   (with-slots (source-pixmap-width source-pixmap-height foreground depth) display-image
  130.     (if (= (image-depth new-source) depth)
  131.     (contact-image-pixmap display-image new-source)
  132.     
  133.     ;; Else expand bitmap to full depth pixmap.
  134.     (contact-image-mask display-image new-source
  135.                 :foreground foreground
  136.                 :background (contact-current-background-pixel display-image)))))
  137.  
  138. (defmethod realize :after ((display-image display-image))
  139.   (with-slots (source source-pixmap) display-image
  140.     (when source
  141.       (setf source-pixmap (realize-display-image display-image source)))))
  142.  
  143. (defmethod (setf contact-foreground) :after (new-value (display-image display-image))
  144.   (declare (ignore new-value))
  145.   (with-slots (source source-pixmap) display-image
  146.     (when (and source (realized-p display-image))
  147.       (setf source-pixmap (realize-display-image display-image source)))))
  148.  
  149. (defmethod (setf contact-background) :after (new-value (display-image display-image))
  150.   (declare (ignore new-value))
  151.   (with-slots (source source-pixmap) display-image
  152.     (when (realized-p display-image)
  153.       (when source
  154.     (setf source-pixmap (realize-display-image display-image source)))
  155.     
  156.       (clear-area display-image)
  157.       (display display-image))))
  158.  
  159.  
  160.  
  161. ;;;----------------------------------------------------------------------------+
  162. ;;;                                                                            |
  163. ;;;                            Initialization                                  |
  164. ;;;                                                                            |
  165. ;;;----------------------------------------------------------------------------+
  166.  
  167. (defun make-display-image (&rest initargs &key &allow-other-keys)
  168.   (declare (values display-image))
  169.   (apply #'make-contact 'display-image initargs))
  170.  
  171.  
  172. (defmethod initialize-instance :after ((display-image display-image) &key source &allow-other-keys)
  173.   (with-slots (width height) display-image
  174.     ;; Insure that source-pixmap & source-pixmap-width & source-pixmap-height
  175.     ;; get set up if the source arg is specified. Also check for valid source argument.
  176.     (setf (display-image-source display-image) source)
  177.     ;;  Initialize required geometry
  178.     (when (or (zerop width) (zerop height))
  179.       (multiple-value-bind (pwidth pheight)
  180.       (preferred-size display-image :width width :height height)
  181.     (change-geometry display-image :width pwidth :height pheight)))))
  182.  
  183.  
  184. ;;;----------------------------------------------------------------------------+
  185. ;;;                                                                            |
  186. ;;;                        Geometry Management                                 |
  187. ;;;                                                                            |
  188. ;;;----------------------------------------------------------------------------+
  189.  
  190. (defmethod preferred-size ((display-image display-image) &key width height border-width)
  191.   (declare (values preferred-width preferred-height preferred-border-width))
  192.  
  193.   (with-slots
  194.     ((current-border-width border-width) (current-height height) (current-width width) gravity
  195.      source-pixmap-height source-pixmap-width)
  196.     display-image
  197.  
  198.     (values
  199.       ;;  Preferred-width
  200.       (max (or width current-width) source-pixmap-width)
  201.  
  202.       ;;  Preferred-height
  203.       (max (or height current-height) source-pixmap-height)
  204.  
  205.       ;;  Preferred-border-width
  206.       (max 0 (or border-width current-border-width)))))
  207.  
  208.  
  209. ;;;----------------------------------------------------------------------------+
  210. ;;;                                                                            |
  211. ;;;                                  DISPLAY                                   |
  212. ;;;                                                                            |
  213. ;;;----------------------------------------------------------------------------+
  214.  
  215.       
  216.  
  217. (defmethod display ((display-image display-image) &optional (exposed-x 0) (exposed-y 0) exposed-width exposed-height &key)
  218.   (with-slots
  219.     (source-pixmap source-pixmap-height source-pixmap-width gravity width height clip-rectangle)
  220.     display-image
  221.     
  222.     (when source-pixmap
  223.       (let ((exposed-width  (or exposed-width (- width exposed-x)))
  224.         (exposed-height (or exposed-height (- height exposed-y)))
  225.         (tiled-p        (eq gravity :tiled)))
  226.     
  227.     (using-gcontext
  228.       (gc :drawable   display-image
  229.           :exposures  :off
  230.           :clip-mask  clip-rectangle
  231.           :fill-style (when tiled-p :tiled) 
  232.           :tile       (when tiled-p source-pixmap)
  233.           :ts-x       (when tiled-p (display-clip-x display-image))        
  234.           :ts-y       (when tiled-p (display-clip-y display-image)))
  235.       
  236.       (if tiled-p
  237.           (draw-rectangle
  238.         display-image gc exposed-x exposed-y exposed-width exposed-height :fill-p)
  239.  
  240.           (multiple-value-bind (extent-x extent-y)
  241.           (case gravity
  242.             (:north-west
  243.              (values
  244.                (display-clip-x display-image)
  245.                (display-clip-y display-image)))
  246.             
  247.             (:north
  248.              (values
  249.                (+ (display-clip-x display-image)
  250.               (pixel-round (- (display-clip-width display-image) source-pixmap-width) 2))
  251.                (display-clip-y display-image)))
  252.             
  253.             (:north-east
  254.              (values
  255.                (+ (display-clip-x display-image)
  256.               (- (display-clip-width display-image) source-pixmap-width))
  257.                (display-clip-y display-image)))
  258.             
  259.             (:west
  260.              (values
  261.                (display-clip-x display-image)
  262.                (+ (display-clip-y display-image)
  263.               (pixel-round (- (display-clip-height display-image) source-pixmap-height) 2))))
  264.             
  265.             (:center
  266.              (values
  267.                (+ (display-clip-x display-image)
  268.               (pixel-round (- (display-clip-width display-image) source-pixmap-width) 2))
  269.                (+ (display-clip-y display-image)
  270.               (pixel-round (- (display-clip-height display-image) source-pixmap-height) 2))))
  271.             
  272.             (:east
  273.              (values
  274.                (+ (display-clip-x display-image)
  275.               (- (display-clip-width display-image) source-pixmap-width))
  276.                (+ (display-clip-y display-image)
  277.               (pixel-round (- (display-clip-height display-image) source-pixmap-height) 2))))
  278.             
  279.             (:south-west
  280.              (values
  281.                (display-clip-x display-image)
  282.                (+ (display-clip-y display-image)
  283.               (- (display-clip-height display-image) source-pixmap-height))))
  284.             
  285.             (:south
  286.              (values
  287.                (+ (display-clip-x display-image)
  288.               (pixel-round (- (display-clip-width display-image) source-pixmap-width) 2))
  289.                (+ (display-clip-y display-image)
  290.               (- (display-clip-height display-image) source-pixmap-height))))
  291.             
  292.             (:south-east
  293.              (values
  294.                (+ (display-clip-x display-image)
  295.               (- (display-clip-width display-image) source-pixmap-width))
  296.                (+ (display-clip-y display-image)
  297.               (- (display-clip-height display-image) source-pixmap-height)))))
  298.         (multiple-value-setq (exposed-x exposed-y exposed-width exposed-height)
  299.           (area-overlaps-p
  300.             exposed-x exposed-y exposed-width       exposed-height
  301.             extent-x  extent-y  source-pixmap-width source-pixmap-height))
  302.         (when exposed-x
  303.           (copy-area
  304.             source-pixmap gc
  305.             (- exposed-x extent-x) (- exposed-y extent-y) exposed-width exposed-height
  306.             display-image exposed-x exposed-y)))))))))
  307.  
  308.  
  309. (defmethod resize :around ((display-image display-image) new-width new-height new-border-width)
  310.   (with-slots (width height  border-width gravity) display-image
  311.     (let* ((delta-width  (- new-width width))
  312.        (delta-height (- new-height height))
  313.       
  314.        ;; Establish new size.
  315.        (resized-p    (call-next-method)))
  316.       
  317.       (unless
  318.     (or (not resized-p)
  319.         
  320.         ;; If bit-gravity is :forget, then usual exposure handling is sufficient.
  321.         (case gravity
  322.           ((:north :south)
  323.            (/= (display-left-margin display-image) (display-right-margin display-image)))
  324.           
  325.           ((:west :east)
  326.            (/= (display-top-margin display-image) (display-bottom-margin display-image)))
  327.           
  328.           (:center
  329.            (or (/= (display-left-margin display-image) (display-right-margin display-image))
  330.            (/= (display-top-margin display-image) (display-bottom-margin display-image))))))
  331.     
  332.     ;; Otherwise, must redisplay part of image previously obscured by margins.
  333.     (cond
  334.       ((plusp delta-width)
  335.        ;; Redisplay exposed part of left margin.
  336.        (multiple-value-bind (left-x left-y left-width left-height)
  337.            (case gravity
  338.          ((:north :center :south)
  339.           (values
  340.             (display-clip-x display-image) (display-clip-y display-image)
  341.             (pixel-round delta-width 2) (display-clip-height display-image)))
  342.          
  343.          ((:north-east :east :south-east)
  344.           (values
  345.             (display-clip-x display-image) (display-clip-y display-image)
  346.             delta-width (display-clip-height display-image))))
  347.          (when left-x
  348.            (display display-image left-x left-y left-width left-height)))
  349.        
  350.        ;; Redisplay exposed part of right margin.
  351.        (multiple-value-bind (right-x right-y right-width right-height)
  352.            (case gravity
  353.          ((:north :center :south)
  354.           (let ((delta (pixel-round delta-width 2)))
  355.             (values
  356.               (- width (display-right-margin display-image) delta) (display-clip-y display-image)
  357.               delta (display-clip-height display-image))))
  358.          
  359.          ((:north-west :west :south-west :tiled)
  360.           (values
  361.             (- width (display-right-margin display-image) delta-width) (display-clip-y display-image)
  362.             delta-width (display-clip-height display-image))))
  363.          (when right-x
  364.            (display display-image right-x right-y right-width right-height))))
  365.       
  366.       (:else
  367.        ;; Clear out left margin for smaller window.
  368.        (unless (case gravity ((:north-west :west :south-west) t))
  369.          (clear-area display-image
  370.              :x 0 :y 0
  371.              :width (display-left-margin display-image) :height height))
  372.        
  373.        ;; Clear out right margin for smaller window.
  374.        (unless (case gravity ((:north-east :east :south-east) t))
  375.          (clear-area display-image
  376.              :x (- width (display-right-margin display-image)) :y 0
  377.              :width (display-right-margin display-image) :height height))))
  378.     
  379.     (cond
  380.       ((plusp delta-height)
  381.        ;; Redisplay exposed part of top margin.
  382.        (multiple-value-bind (top-x top-y top-width top-height)
  383.            (case gravity
  384.          ((:west :center :east)
  385.           (values
  386.             (display-clip-x display-image) (display-clip-y display-image)
  387.             (display-clip-width display-image) (pixel-round delta-height 2)))
  388.          
  389.          ((:south-west :south :south-east)
  390.           (values
  391.             (display-clip-x display-image) (display-clip-y display-image)
  392.             (display-clip-width display-image) delta-height)))
  393.          (when top-x
  394.            (display display-image top-x top-y top-width top-height)))
  395.        
  396.        ;; Redisplay exposed part of bottom margin.
  397.        (multiple-value-bind (bottom-x bottom-y bottom-width bottom-height)
  398.            (case gravity
  399.          ((:west :center :east)
  400.           (let ((delta (pixel-round delta-height 2)))
  401.             (values
  402.               (display-clip-x display-image) (- height (display-bottom-margin display-image) delta)
  403.               (display-clip-width display-image) delta)))
  404.          
  405.          ((:north-west :north :north-east :tiled)
  406.           (values
  407.             (display-clip-x display-image) (- height (display-bottom-margin display-image) delta-height)
  408.             (display-clip-width display-image) delta-height)))
  409.          (when bottom-x
  410.            (display display-image bottom-x bottom-y bottom-width bottom-height))))
  411.       
  412.       (:else
  413.        ;; Clear out top margin for smaller window.
  414.        (unless (case gravity ((:north-west :north :north-east) t))
  415.          (clear-area display-image
  416.              :x 0 :y 0
  417.              :width width :height (display-top-margin display-image)))
  418.        
  419.        ;; Clear out bottom margin for smaller window.
  420.        (unless (case gravity ((:south-west :south :south-east) t))
  421.          (clear-area display-image
  422.              :x 0 :y (- height (display-bottom-margin display-image))
  423.              :width width :height (display-bottom-margin display-image))))))
  424.  
  425.       resized-p)))
  426.  
  427.